home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / vaxlap.t < prev    next >
Text File  |  1988-02-05  |  10KB  |  324 lines
  1. (herald vaxlap (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.         
  26. ;;; lap code is of the form (lap free-vars . code)
  27. ;;; lap templates are (lap-template (pointer scratch nargs) . code)
  28.  
  29. (define local-processor
  30.   (lambda ()
  31.     (object nil
  32.       ((processor-type self)     'vax11)
  33.       ((vax-processor? self) '#t)
  34.       ((print-type-string self)  "Processor"))))
  35.  
  36. (define (invoke-stack-continuation frame vals)
  37.   (lap (return apply)
  38.     (subl2 ($ 2) A1)
  39.     (movl A1 SP)
  40.     (cmpl A2 nil-reg)
  41.     (beql (to no-values))
  42.     (cmpl (d@r A2 -3) nil-reg)
  43.     (bneq (to many-values))
  44.     (movl (d@r A2 1) A1)
  45.     (mnegl ($ 2) NARGS)
  46.     (movl (@r sp) tp)
  47.     (jmp (@r tp))
  48. no-values
  49.     (mnegl ($ 1) NARGS)
  50.     (movl (@r sp) tp)
  51.     (jmp (@r tp))
  52. many-values
  53.     (movl (d@r P (static 'return)) A1)
  54.     (movl (d@r a1 2) a1)
  55.     (movl (d@r P (static 'apply)) P)
  56.     (movl (d@r p 2) p)
  57.     (movl ($ 3) NARGS)
  58.     (movl (d@r p -2) tp)
  59.     (jmp (@r tp))))
  60.  
  61.  
  62. (define (invoke-continuation sp stack val base-state current-state)
  63.   (lap (rewind-state-and-continue)
  64.     (movl A1 SP)                    ; set new continuation
  65.     (movl (d@r TASK task/stack) S0) ; limit at stack base
  66.     (addl2 ($ 2) A2)                  ; start at first word of stack in heap
  67.     (brb (to copy-stack-test))
  68. copy-stack-loop 
  69.     (movl (@r+ A2) (@r+ A1))
  70. copy-stack-test
  71.     (cmpl A1 S0)
  72.     (bleq (to copy-stack-loop))
  73.     (movl A4 A1)
  74.     (movl (d@r TASK 16) A2)
  75.     (movl (d@r P (static 'rewind-state-and-continue)) P)
  76.     (movl (d@r p 2) p)
  77.     (movl ($ 4) NARGS)
  78.     (movl (d@r p -2) tp)
  79.     (jmp (@r tp))))
  80.  
  81.  
  82.  
  83.  
  84. ;;; (FIXNUM-HOWLONG n)
  85. ;;;   Returns the number of bits in N's binary representation.
  86. ;;;   Horrible name, after MACLISP function HAULONG.
  87.  
  88. (define (fixnum-howlong num)
  89.  (lap ()
  90.   (rotl ($ -2) A1 S0)        
  91.   (clrl A1)
  92.   (bitl ($ #xffff8000) S0)
  93.   (beql (to howlong1))
  94.   (bisl2 ($ (* 16 4)) A1)
  95.   (ashl ($ -16) S0 S0)
  96. howlong1
  97.   (bitl ($ #x7f80) S0)
  98.   (beql (to howlong2))
  99.   (bisl2 ($ (* 8 4)) A1)
  100.   (ashl ($ -8) S0 S0)
  101. howlong2
  102.   (bitl ($ #x78) S0)
  103.   (beql (to howlong3))
  104.   (bisl2 ($ (* 4 4)) A1)
  105.   (ashl ($ -4) S0 S0)
  106. howlong3
  107.   (bitl ($ #x6) S0)
  108.   (beql (to howlong4))
  109.   (bisl2 ($ (* 2 4)) A1)
  110.   (ashl ($ -2) S0 S0)
  111. howlong4
  112.   (bitl ($ #x1) S0)
  113.   (beql (to howlong5))
  114.   (bisl2 ($ (* 1 4)) A1)
  115. howlong5  
  116.   (mnegl ($ 2) NARGS)
  117.     (movl (@r sp) tp)
  118.     (jmp (@r tp))))
  119.  
  120.  
  121. (define (*set x y)
  122.   (lap ()  
  123.     (movl A2 (d@r A1 2))
  124.     (tstb (@r A1))
  125.     (beql (to foo-set))
  126.     (movl A1 (d@r TASK task/extra-pointer))
  127.     (jsb (*d@r nil-reg slink/set))
  128. foo-set
  129.     (mnegl ($ 2) NARGS)
  130.     (movl (@r sp) tp)
  131.     (jmp (@r tp))))
  132.  
  133.  
  134. (define (apply-traced-operation proc . args)
  135.   (lap (*traced-op-template*)
  136.     (movl (d@r P (static '*traced-op-template*)) TP)
  137.     (movl (d@r tp 2) tp)
  138.     (clrl (d@r TASK task/extra-scratch))
  139.     (jmp (label entry))))
  140.  
  141. (define (apply proc . args)
  142.  (lap (apply-too-many-args)                 
  143.   (movl ($ 1) (d@r TASK task/extra-scratch))
  144. entry
  145.   (decl NARGS)                        ;; shift proc out
  146.   (pushl P)                           ;; save env
  147.   (movl A1 P)                         ;; first arg is proc
  148.   (cmpl NARGS ($ 1))                  ;; no args to proc
  149.   (beql (to apply-done))
  150.   (decl NARGS)
  151.   (cmpl NARGS ($ 1))
  152.   (bneq (to next1))
  153.   (movl A2 AN)
  154.   (jmp (label apply-one-arg))
  155. next1
  156.   (cmpl NARGS ($ 2))
  157.   (bneq (to next2))
  158.   (movl A2 A1)
  159.   (movl A3 AN)
  160.   (jmp (label apply-two-args))
  161. next2
  162.   (cmpl NARGS ($ 3))
  163.   (bneq (to next3))
  164.   (movl A2 A1)
  165.   (movl A3 A2)
  166.   (movl A4 AN)                
  167.   (jmp (label apply-three-args))
  168. next3                         
  169.   (cmpl NARGS ($ 4))
  170.   (bneq (to next4))
  171.   (movl A2 A1)
  172.   (movl A3 A2)
  173.   (movl A4 A3)
  174.   (movl (d@r TASK 16) AN)           ;; first argument temp
  175.   (jmp (label apply-four-args))
  176. next4
  177.   (movl A2 A1)
  178.   (movl A3 A2)
  179.   (movl A4 A3)
  180.   (movl (d@r TASK 16) A4)            ;; first argument temp
  181.   (subl3 ($ 5) NARGS S1)             ;; S1 counts sown to 0
  182.   (addl3 TASK ($ 20) S2)             ;; set up S2 to point into rest vector
  183.                                      ;; first 4 temps reserved, 1 done already
  184.   (jmp (label apply-shift-test))
  185. apply-shift-loop-top
  186.   (movl (d@r S2 0) (d@r S2 -4))
  187.   (decl S1)
  188.   (addl2 ($ 4) S2)
  189. apply-shift-test
  190.   (cmpl S1 ($ 0))
  191.   (bneq (to apply-shift-loop-top))
  192.   (movl (d@r S2 0) AN)  
  193.   (subl2 ($ 4) S2)
  194.   (jmp (label apply-many-args))
  195. apply-one-arg
  196.   (cmpl AN nil-reg)   
  197.   (beql (to apply-done))
  198.   (movl (d@r AN 1) A1)                    
  199.   (addl2 ($ 1) NARGS)
  200.   (movl (d@r AN -3) AN)                   
  201. apply-two-args
  202.   (cmpl AN nil-reg)   
  203.   (beql (to apply-done))
  204.   (movl (d@r AN 1) A2)                    
  205.   (addl2 ($ 1) NARGS)
  206.   (movl (d@r AN -3) AN)                   
  207. apply-three-args
  208.   (cmpl AN nil-reg)   
  209.   (beql (to apply-done))
  210.   (movl (d@r AN 1) A3)                    
  211.   (addl2 ($ 1) NARGS)
  212.   (movl (d@r AN -3) AN)                   
  213. apply-four-args
  214.   (cmpl AN nil-reg)   
  215.   (beql (to apply-done))
  216.   (movl (d@r AN 1) A4)                    
  217.   (addl2 ($ 1) NARGS)
  218.   (movl (d@r AN -3) AN)      
  219.   (addl3 TASK ($ 16) S0)
  220. apply-spread-loop              
  221.   (cmpl AN nil-reg)
  222.   (beql (to apply-done))
  223.   (movl (d@r AN 1) (d@r S0 0))
  224.   (addl2 ($ 1) NARGS)
  225.   (cmpl ($ (+ *pointer-temps* 1)) NARGS)
  226.   (blss (to too-many))
  227.   (addl2 ($ 4) S0)
  228.   (movl (d@r AN -3) AN)
  229.   (jmp (label apply-spread-loop))
  230. too-many
  231.   (movl (@r+ SP) P)
  232.   (movl ($ 2) NARGS)
  233.   (movl (d@r P (static 'apply-too-many-args)) P)
  234.   (movl (d@r p 2) p)
  235.   (movl (d@r p -2) tp)
  236.   (jmp (@r tp))
  237. apply-done                    
  238.   (addl2 ($ 4) SP)
  239.   (tstl (d@r TASK task/extra-scratch))
  240.   (beql (to traced))
  241.   (movl (d@r p -2) tp)
  242.   (jmp (@r tp))
  243. traced
  244.   (jmp (@r TP))))
  245.  
  246.  
  247.  
  248.  
  249. (define (string-hash string)
  250.   ;; string in A1
  251.   (lap ()
  252.     ;; enter critical gc
  253.     (addl3 (d@r A1 offset/string-text) ($ 2) A3);; raw string text in A3
  254.     (addl2 (d@r A1 offset/string-base) A3)                              
  255. hash
  256.     (ashl ($ -8) (d@r A1 -2) S0)              ;; string-length in S0
  257.     (clrl S1)                                 ;; conter in S1
  258.     (clrl S2)                                 ;; hash value so far in S2
  259.     (jmp (label hash-test))
  260. hash-loop              
  261.     (rotl ($ 1) S2 S2)
  262.     (addb2 (@r+ A3) S2)
  263. hash-test  
  264.     (aobleq S0 S1 (to hash-loop))
  265.     (rotl ($ 16) S2 S1)
  266.     (xorl2 S1 S2)
  267.     (bicl3 ($ #x80000003) S2 A1)              ;; positive-fixnumize
  268.     ;; exit critical gc                       ;; blat bits 0,1,31
  269.     (mnegl ($ 2) NARGS)
  270.     (movl (@r sp) tp)
  271.     (jmp (@r tp))))
  272.  
  273.  
  274.  
  275.  
  276. ;;;  magic frame is next-state
  277. ;;;                 winder
  278. ;;;                 previous-state
  279. ;;;                 unwinder
  280. ;;;                 *magic-frame-template*
  281.  
  282. (define (push-magic-frame unwinder stuff wind)   
  283.  (lap (*magic-frame-template* bind-internal)
  284.   (movl (d@r TASK task/dynamic-state) AN)
  285.   (pushl nil-reg)                                      ; next state
  286.   (pushl A3)                                           ; winder
  287.   (pushl AN)                                           ; previous state
  288.   (pushl A1)                                          ; unwinder
  289.   (movl (d@r P (static '*magic-frame-template*)) a3)
  290.   (pushl (d@r a3 2))
  291.   (addl3 SP ($ 2) A1)                  ; first arg is the magic frame
  292.   (cmpl AN nil-reg)                     ; is there a previous state?
  293.   (beql (to magic-frame-exit))
  294.   (movl A1 (d@r AN 14))                ; set next slot to this magic frame
  295. magic-frame-exit
  296.   (movl (d@r P (static 'bind-internal)) P)   ; second arg is stuff
  297.   (movl (d@r p 2) p)
  298.   (movl ($ 3) NARGS)
  299.     (movl (d@r p -2) tp)
  300.     (jmp (@r tp))))
  301.  
  302.                    
  303. (define (make-structure-template size)
  304.   (lap (*structure-template* *stype-template*)
  305.     (movl (d@r P (static '*stype-template*)) AN)
  306.     (movl (d@r an 2) an)
  307.     (movl ($ 36) S1)                            ; 9 slots
  308.     (jsb (*d@r nil-reg slink/make-extend))
  309.     (movw ($ 32) (d@r AN 26))                     ; offset within closure
  310.     (movb ($ 0) (d@r AN 28))                     ; 0 scratch slots
  311.     (ashl ($ -2) A1 S0)                         ; pointer slots
  312.     (movb S0 (d@r AN 29))
  313.     (movw ($ header/template) (d@r AN 30))
  314.     (movw ($ VAX-JUMP-ABSOLUTE) (d@r AN 32))
  315.     (movl (d@r P (static '*structure-template*)) p)
  316.     (movl (d@r p 2) (d@r AN 34)) ; auxilliary
  317.     (moval (d@r AN 32) A1)                       ; template
  318.     (movl AN A2)                                ; stype
  319.     (mnegl ($ 3) NARGS)                         ; return two values
  320.     (movl (@r sp) tp)
  321.     (jmp (@r tp))))
  322.  
  323.  
  324.